{-# OPTIONS_GHC -fglasgow-exts #-}
module Relational.Internal where
import Language.Haskell.TH
import Data.List

type Dim = Char

-- [ [ (type name, constructor name) ] ] -> Q [Dec]
isomorphisms :: [[(Name,Name)]] -> Q [Dec]
isomorphisms = return . foldl1' (++) . map (map declare . permuteCombos 2)
    where declare [(a,a'),(b,b')] = InstanceD
                []
                (mkParametricT [ConT (mkName "Isomorphism"),
                                ConT a,
                                ConT b])
                [FunD (mkName "isomorph") [ Clause
                    [ ConP a' [VarP (mkName "x")] ]
                    (NormalB (AppE (ConE b')
                                   (VarE (mkName "x") ) ) )
                    [] ] ]

expandIsomorphismsUpToDim :: Int -> Q [Dec]
expandIsomorphismsUpToDim = return . map declare .
        filter (\(a,b)-> length a == length b) . expandedReductionsUpToDim
    where declare (r,p) = InstanceD
            (map (\(a,b)-> mkParametricT [ConT (mkName "Isomorphism")
                                     ,mkTupT [a]
                                     ,mkTupT [b] ])
                 (zip r p))
            (mkParametricT [ConT (mkName "Isomorphism"), mkTupT r, mkTupT p])
            [FunD (mkName "isomorph") [ Clause
                [mkTupP (map Just r)]
                (NormalB $ TupE  (map (\c-> AppE (VarE $ mkName "isomorph") (VarE $ mkName [c]) ) r))
                [] ] ]

projectionsUpToDim :: Int -> Q [Dec]
projectionsUpToDim = return . map declare . reductionsUpToDim
    where declare (r,p) = InstanceD
            []
            (mkParametricT [ConT (mkName "Projection"), mkTupT r, mkTupT p])
            [FunD (mkName "project") [ Clause
                [mkWildTupP p r]
                (NormalB $ mkTupE p)
                [] ] ]

expandProjectionsUpToDim :: Int -> Q [Dec]
expandProjectionsUpToDim = return . map declare . expandedReductionsUpToDim
    where declare (r,p) = InstanceD
            (map (\c-> mkParametricT [ConT (mkName "Projection")
                                     ,mkTupT r
                                     ,mkTupT [c] ])
                  p)
            (mkParametricT [ConT (mkName "Projection"), mkTupT r, mkTupT p])
            [FunD (mkName "project") [ Clause
                [VarP (mkName "r")]
                (NormalB $ TupE  (map (\_-> AppE (VarE $ mkName "project")
                                                 (VarE $ mkName "r") )
                                      p))
                [] ] ]

joinsUpToDim :: Int -> Q [Dec]
joinsUpToDim = return . map declare . expansionsUpToDim
    where declare (r1,r2) = InstanceD
            (mkParametricT [ConT (mkName "Eq"), mkTupT tang] : [])
            (mkParametricT [ConT (mkName "Join"),
                            AppT ListT (mkTupT r1),
                            AppT ListT (mkTupT r2),
                            AppT ListT (mkTupT prod) ] )
            [FunD (mkName "join") [ Clause
                [VarP (mkName "r1"), VarP (mkName "r2")]
                (NormalB $ CompE [
                    BindS (mkTupP $ map Just r1)
                          (VarE $ mkName "r1"),
                    BindS (TupP $ map (\c-> VarP $ mkName $ if any (==c) tang
                                                            then c:"2"
                                                            else [c])
                                    r2)
                          (VarE $ mkName "r2"),
                    NoBindS (InfixE
                                (Just $ mkTupE tang)
                                (VarE $ mkName "==")
                                (Just $ if length tang == 1
                                          then VarE $ mkName (tang++"2")
                                          else TupE $ map (\c->
                                                VarE $ mkName (c:"2")) tang) ),
                    NoBindS $ mkTupE prod] )
                [] ] ]
            where tang = r1 `tangent`  r2
                  prod = r1 `product'` r2

-- dimensional tangent
tangent :: [Dim] -> [Dim] -> [Dim]
tangent r = sort . filter (\x-> any (==x) r)

-- dimensional product
product' :: [Dim] -> [Dim] -> [Dim]
product' r = sort . nub . (++) r

-- one dimensional reduction possibilities anamorphism
-- dimensional limit -> [( dimentions, reduction )]
reductionsUpToDim :: Int -> [([Dim],[Dim])]
reductionsUpToDim = foldl1' (++) . map (\x-> uncurry (map . (,))
    (x, combinations 1 x)) .
    tail . inits . mkSeq 'a'

-- multidimensional dimention-polymorphic reduction possibilities anamorphism
-- dimensional limit -> [( dimentions, polymorphic reduction )]
expandedReductionsUpToDim :: Int -> [([Dim],[Dim])]
expandedReductionsUpToDim = foldl1' (++) . map (uncurry (map . (,)) .
    (\x->(x,map (mkSeq (succ $ last x)) [2..length x]))) .
    tail . tail . inits . mkSeq 'a'

-- dimensional expansion possibilities anamorphism
-- dimensional limit -> [( dimentions A, dimentions B )]
expansionsUpToDim :: Int -> [([Dim],[Dim])]
expansionsUpToDim n = foldl1' (++) $ (map (\x->uncurry (map . (,)) $
    (x,foldl1' (++) $ map (permuteOnly x) $ foldl1' (++) $ map (\y-> map (\x->x++y)
    (foldl1' (++) $ map (flip combinations x) [1..length x-1])) $ tail $ inits $
    mkSeq (succ $ last x) (n-length x))) . tail . tail . inits . mkSeq 'a') (n-1)

permuteCombos :: (Integral t) => t -> [a] -> [[a]]
permuteCombos n = foldl1' (++) . map permutations . combinations n

permuteOnly :: (Eq a) => [a] -> [a] -> [[a]]
permuteOnly x = nubBy (\a b-> map (flip elemIndex x) a == map (flip elemIndex x) b) . permutations

permutations :: [a] -> [[a]]
permutations [] = [ [] ]
permutations xs = [ x:zs | (x,ys) <- expose xs, zs <- permutations ys ]
             where expose xs      = step [] xs
                   step _  []     = []
                   step ys (x:xs) = (x,ys++xs):step (ys++[x]) xs

combinations :: (Integral t) => t -> [a] -> [[a]]
combinations 0 _  = [ [] ]
combinations n xs = [ y:ys | y:xs' <- tails xs
                           , ys <- combinations (pred n) xs' ]

insertAt :: a -> Int -> [a] -> [a]
insertAt c i = (\(a,b)-> a++[c]++b) . splitAt i

mkSeq :: (Num a, Ord a, Enum a, Enum b) => b -> a -> [b]
mkSeq z n | n < 1     = []
          | otherwise = z : mkSeq (succ z) (pred n)

mkParametricT :: [Type] -> Type
mkParametricT = foldl1' AppT

mkFunT :: [Type] -> Type
mkFunT = foldl1' $ \t1 t2-> AppT (AppT ArrowT t1) t2

mkTupT :: [Dim] -> Type
mkTupT (c:[]) = VarT (mkName [c])
mkTupT cs     = foldl' AppT (TupleT (length cs)) (map (VarT . mkName . (:[])) cs)

mkTupP :: [Maybe Dim] -> Pat
mkTupP (c:[]) = _f c
mkTupP cs     = TupP (map _f cs)
_f Nothing  = WildP
_f (Just c) = VarP (mkName [c])

-- needed vars -> all vars -> pattern
mkWildTupP :: [Dim] -> [Dim] -> Pat
mkWildTupP cs = mkTupP . map (\c -> if any (==c) cs then Just c else Nothing)

mkTupE :: [Dim] -> Exp
mkTupE (c:[]) = VarE (mkName [c])
mkTupE cs     = TupE  (map ( VarE . mkName . (:[]) ) cs)

mkAppE :: [Exp] -> Exp
mkAppE = foldl1' AppE


{- removed in favor of one dimensional projections design with
    multidimensional dimesion-polymorphic reduction expansion
    to lower instance count and eliminate overlapping instances.

reductionsUpToDim :: Int -> [([Dim],[Dim])]
reductionsUpToDim = foldl1' (++) . map (\x-> uncurry (map . (,))
    (x,foldl1' (++) $ map (flip permuteCombos x) [1..length x])) .
    tail . inits . mkSeq 'a'
-}

{- removed from design -- use filter

selectionsUpToDim :: Int -> Q [Dec]
selectionsUpToDim = return . map declare . reductionsUpToDim
    where declare (r,p) = InstanceD
            []
            (mkParametricT [ConT (mkName "Selection"),
                            AppT ListT (mkTupT r),
                            mkFunT [mkTupT p, ConT (mkName "Bool")] ] )
            [FunD (mkName "select") [ Clause
                [VarP (mkName "r"), VarP (mkName "p")]
                (NormalB $ mkAppE [VarE (mkName "filter"),
                                   (LamE [mkWildTupP p r] (mkAppE [
                                                            VarE (mkName "p"),
                                                            mkTupE p ])),
                                   VarE (mkName "r") ] )
                [] ] ]
-}

